(in-package :parameterscout)

(defmacro closer-to-sorter (target)
  "Return a function which compares two values based on which one
  is closer to TARGET."
  (once-only (target)
    `#'(lambda (x y)
	 (declare (double-float x y ,target)
		  (optimize (speed 3) (safety 0) (debug 1)))
	 (let ((delta-x (abs (- ,target x)))
	       (delta-y (abs (- ,target y))))
	   (< delta-x delta-y)))))

;; Macros, yo!
;;;;;;;;;;;;;;

(defun identify-free-variables (expr)
  "Identify free variables floating around in EXPR. This is a
nasty fragile hack that will explode if you use it on something
other than a bog-standard arithmetic expression."
  (sort
   (remove-duplicates
    (typecase expr
      (list (apply #'concatenate 'list
		   (mapcar #'identify-free-variables (cdr expr))))
      (symbol (unless (boundp expr) (list expr)))
      (t nil)))
   #'string< :key #'symbol-name))

(defmacro sweep-through-values ((variable values) &body body)
  "Generate code to evaluate BODY for all values of VARIABLE
contained in the array specified by VALUES. Takes place in a LOOP
form, so some special consequences follow from that, none of
which should be relevant to this particular program."
  `(loop for ,variable across ,values do (progn ,@body)))

(defmacro sweep-variables-through-values (bindings &body body)
  (if bindings
      (let ((first-variable (first (first bindings)))
	    (first-values  (second (first bindings)))
	    (rest-of-bindings (cdr bindings)))
	`(sweep-through-values (,first-variable ,first-values)
	   (sweep-variables-through-values ,rest-of-bindings
	     ,@body)))
      `(progn ,@body)))

#+nil
(collecting
  (sweep-variables-through-values ((x #(1 2 3))
				   (y #(a b c)))
    (collect (list y x))))

(defmacro make-search-all-code (expr free-variable-bindings target)
  "Like MAKE-SEARCH-CODE but returns a list of all solutions which are equally good."
  (with-unique-names (possible-values)
    `(let ((,possible-values
	    (collecting
	      (sweep-variables-through-values ,free-variable-bindings
		(handler-case (collect (vector ,expr ,@(mapcar #'car free-variable-bindings)))
		  (division-by-zero (e) (declare (ignore e)))
		  (floating-point-invalid-operation (e) (declare (ignore e))))))))
       (extrema ,possible-values (closer-to-sorter ,target) :key #'(lambda (v) (svref v 0))))))

(defmacro make-search-code (expr free-variable-bindings target)
  (with-unique-names (possible-values)
    `(let ((,possible-values
	    (collecting
	      (sweep-variables-through-values ,free-variable-bindings
		(handler-case (collect (vector ,expr ,@(mapcar #'car free-variable-bindings)))
		  (division-by-zero (e) (declare (ignore e)))
		  (floating-point-invalid-operation (e) (declare (ignore e))))))))
       (extremum ,possible-values (closer-to-sorter ,target) :key #'(lambda (v) (svref v 0))))))

(defmacro perform-search (expr free-variable-bindings target)
  "Similar to MAKE-SEARCH-ALL-CODE, but actually performs search."
  #-ecl `(funcall (compile nil `(lambda ()
				  #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
				  (make-search-all-code ,,expr ,,free-variable-bindings ,,target))))
  #+ecl `(funcall (eval `(lambda ()
			   #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
			   (make-search-all-code ,,expr ,,free-variable-bindings ,,target)))))


(defmacro make-search-all-code (expr free-variable-bindings target)
  "Like MAKE-SEARCH-CODE but returns a list of all solutions which are equally good."
  (with-unique-names (possible-values)
    `(let ((,possible-values
	    (collecting
	      (sweep-variables-through-values ,free-variable-bindings
		(handler-case (collect (vector ,expr ,@(mapcar #'car free-variable-bindings)))
		  (division-by-zero (e) (declare (ignore e)))
		  (floating-point-invalid-operation (e) (declare (ignore e))))))))
       (extrema ,possible-values (closer-to-sorter ,target) :key #'(lambda (v) (svref v 0))))))

#+nil
(make-search-all-code (/ r1 r2) 
		    ((r1 *standard-resistor-values*)
		     (r2 *standard-resistor-values*))
		    2.2d0)